Clustering Black Friday
library(ggplot2)
library(dplyr)
library(caret)
library(cluster)
library(klaR)
library(clustMixType)
library(data.table)
library(factoextra)
library(tidyr)
library(Rtsne)
library(compareGroups)
library(gridExtra)
library(reshape)Preprocesado de los datos
Leer dataset y mostrar algunas filas
BlackFriday <- read.csv("BlackFriday.csv")
dim(BlackFriday)## [1] 537577 12head(BlackFriday)Cada fila describe una compra de un producto hecha por un cliente determinado
Descripción de atributos
- User_ID: Cateǵorico
- Product_ID: Categórico
- Gender: Categórico (M,F)
- Age: Categórico (0-17, 18-25, 26-35, 36-45, 46-50, 51-55, 55+)
- Occupation: Categórico (0, 1, 2, …, 19, 20)
- City_Category: Categórico (A, B, C)
- Stay_In_Current_City_Years: Cateǵorico (0, 1, 2, 3, 4+)
- Marital_Status: Categórico (0, 1)
- Product_Category_1/2/3: Categórico (1, 2, …, 17, 18)
- Purchase: Numérico
Algunas columnas categóricas no son reconocidas como factors (User_ID, Occupation, Product_Category, Marital_Status)
# Factorizar columnas categóricas
BlackFriday$User_ID <- factor(BlackFriday$User_ID)
BlackFriday$Occupation <- factor(BlackFriday$Occupation)
BlackFriday$Marital_Status <- factor(BlackFriday$Marital_Status)
BlackFriday$Product_Category_1 <- factor(BlackFriday$Product_Category_1)
BlackFriday$Product_Category_2 <- factor(BlackFriday$Product_Category_2)
BlackFriday$Product_Category_3 <- factor(BlackFriday$Product_Category_3)Generación de atributos
Como queremos hacer clustering sobre los clientes, tenemos que agrupar todas las transacciones de cada cliente en una única fila. Unificamos y creamos nuevos atributos basados en ésta agrupación de transacciones:
Atributos de perfil de cliente (User_ID, Gender, Age, Occupation, City_Category, Stay_In_Current_City_Years, Marital_Status). Eliminamos Product_ID.
Número de elementos comprados por cada categoría de producto por cada cliente (18 nuevos atributos)
Gasto total de cada cliente
Perfil de usuario
En primer lugar, creamos un dataframe solamente con el perfil de usuario, eliminando User_ID duplicados. Trataremos la información de compras de productos después
# Seleccionar únicamente columnas de perfil de usuario
BlackFriday_Clustering <- dplyr::select(BlackFriday, User_ID, Gender, Age, Occupation, City_Category, Stay_In_Current_City_Years, Marital_Status)
# Eliminar duplicados
BlackFriday_Clustering <- distinct(BlackFriday_Clustering)La edad y el número de años en la ciudad pueden ser consideradas variables númericas (Age, Stay_In_Current_City_Years). Aunque vienen especificadas de forma categórica, nos interesa que nuestro modelo sea capaz de reconocer que, por ejemplo, dos personas de 18 y 55 años son menos parecidas que dos de 30 y 40. Si lo expresamos de forma categórica, la distancia entre todos los grupos será la misma. Por lo tanto, vamos a usar para la edad el valor medio de cada grupo. Para el número de años en la ciudad consideramos el 4+ como un 4.
# Convertir Age & Stay_In_Current_City_Years a atributos numéricos
# Age
BlackFriday_Clustering$Age_Int[BlackFriday_Clustering$Age=='0-17'] <- 15
BlackFriday_Clustering$Age_Int[BlackFriday_Clustering$Age=='18-25'] <- 22
BlackFriday_Clustering$Age_Int[BlackFriday_Clustering$Age=='26-35'] <- 30
BlackFriday_Clustering$Age_Int[BlackFriday_Clustering$Age=='36-45'] <- 40
BlackFriday_Clustering$Age_Int[BlackFriday_Clustering$Age=='46-50'] <- 48
BlackFriday_Clustering$Age_Int[BlackFriday_Clustering$Age=='51-55'] <- 53
BlackFriday_Clustering$Age_Int[BlackFriday_Clustering$Age=='55+'] <- 60
BlackFriday_Clustering$Age <- NULL
# Stay_In_Current_City_Years
BlackFriday_Clustering$Stay_In_Current_City_Years <-
as.numeric(BlackFriday_Clustering$Stay_In_Current_City_Years) - 1Información de compras
Añadimos la información de compras a cada usuario (categoría de producto y gasto total)
Para las categorías de producto existen varias opciones:
- Generar 18 nuevos atributos que expresen el número de items comprado por cada categoría de producto
- Generar 18 nuevos atributos que expresen la suma total gastada por categoría de producto
# Número de items comprados por cada categoría de producto
purchase_category <- dplyr::select(BlackFriday, User_ID, Product_Category_1, Purchase) %>%
group_by(User_ID, Product_Category_1) %>%
summarise(Purchase = length(Purchase)) %>%
spread(key=Product_Category_1, value=Purchase, fill=0) %>%
ungroup()
# Renombrar columnas
for (n in names(purchase_category)[-1]){
new_colname <- paste("Product_Category_",n,sep="")
names(purchase_category)[names(purchase_category)==paste(n)] <- paste(new_colname)
}
BlackFriday_Clustering <- merge(BlackFriday_Clustering,purchase_category, by="User_ID")
head(purchase_category)# Suma total gastada por categoría de producto
# purchase_category <- dplyr::select(BlackFriday,User_ID,Product_Category_1,Purchase) %>%
# group_by(User_ID,Product_Category_1) %>%
# summarise(Purchase = sum(Purchase)) %>%
# spread(key=Product_Category_1, value=Purchase, fill=0) %>%
# ungroup()
#
# # Rename columns
# for (n in names(purchase_category)[-1]){
# new_colname <- paste("Product_Category_",n,sep="")
# names(purchase_category)[names(purchase_category)==paste(n)] <- paste(new_colname)
# }
# BlackFriday_Clustering <- merge(BlackFriday_Clustering,purchase_category, by="User_ID")
# head(purchase_category)Generamos una columna de gasto total de cada cliente
# Gasto total de cada cliente
purchase_sum <- aggregate(Purchase ~ User_ID, data=BlackFriday, sum)
BlackFriday_Clustering <- merge(BlackFriday_Clustering,purchase_sum, by="User_ID")Eliminamos User_ID y visualizamos el dataframe transformado para clustering
BlackFriday_Clustering$User_ID <- NULL
head(BlackFriday_Clustering)Clustering
Una vez tenemos los datos agrupados por cliente, podemos hacer clustering para intentar identificar grupos con clientes similares. Dado que tenemos una mezcla de variables categóricas y numéricas, consideramos varias opciones:
K-means codificando las variables categóricas (one-hot encoding). El k-means necesita que todas las variables sean númericas para medir la distancia Euclídea.
K-prototypes (Como el K-means pero se puede usar con variables categóricas y numéricas: Los centroides (cluster prototypes) son las medias para atributos numericos y la moda para los categóricos)
K-medoids con distancia Gower (los centros, en vez de las medias, son instancias y se calcula una matriz de disimilitud de cada instancia frente a otra)
K-means
Para utilizar el K-means creamos un nuevo dataframe (BlackFriday_ohe) con las variables categóricas codificadas one-hot.
# One-hot encoding
dmy <- dummyVars(" ~ .", data = BlackFriday_Clustering)
BlackFriday_ohe <- data.frame(predict(dmy, newdata = BlackFriday_Clustering))
# Eliminar una de las columnas de variables que solo tengan dos valores (Gender and Marital_Status)
BlackFriday_ohe$Gender.F <- NULL
BlackFriday_ohe$Marital_Status.0 <- NULLNormalizamos columnas numéricas. Como su rango es mayor, las distancias pueden ser grandes. Si no las normalizamos tendrán mayor influencia que las demás variables categóricas codificadas.
# BlackFriday_ohe <- rescaler(BlackFriday_ohe, "range")
cols_to_scale <- grep( "Product_Category", names(BlackFriday_ohe),value=T)
cols_to_scale <- c(cols_to_scale, "Age_Int","Stay_In_Current_City_Years","Purchase" )
BlackFriday_ohe <- BlackFriday_ohe %>% mutate_each_(funs(scale(.) %>% as.vector), vars=cols_to_scale)## `mutate_each()` is deprecated.
## Use `mutate_all()`, `mutate_at()` or `mutate_if()` instead.
## To map `funs` over a selection of variables, use `mutate_at()`Visualizar dataframe BlackFriday_ohe para el K-means
head(BlackFriday_ohe)Buscamos el número óptimo de clusters con el Elbow method (total within-cluster sum of square (wss))
wss <- 0
for (i in 1:15) {
km.out <- kmeans(BlackFriday_ohe, centers = i, nstar=5)
wss[i] <- km.out$tot.withinss
}## Warning: did not converge in 10 iterations
## Warning: did not converge in 10 iterationsplot(1:15, wss, type = "b", xlab = "Number of Clusters",
ylab = "Within groups sum of squares")
Visualización de los resultados en 2D en función del número de clusters. Se reduce la dimensionalidad usando PCA y se enfrentan las dos componentes principales
for (k in 3:6){
km <- kmeans(BlackFriday_ohe, centers=k, nstar=5)
fv <- fviz_cluster(km, geom = "point", data = BlackFriday_ohe) + ggtitle(paste("2D Cluster solution (k=", k, ")", sep=""))
plot(fv)
}
Escogemos 4 clusters como el mejor valor
k <- 4
reskm <- kmeans(BlackFriday_ohe, centers=k, nstar=5)
BlackFriday_Clustering$cluster_kmeans <- as.factor(reskm$cluster)Se crea la función clusterAnalysis para intentar interpretar los resultados del clustering, identificando las características propias de cada grupo.
Primero se muestra una tabla con los distintos valores de atributos en cada cluster.
Como es difícil extraer conclusiones de las tablas, mostramos gráficas de la distribución de los valores de atributos en cada cluster.
Para las variables continuas usamos boxplots que muestran valor mínimo, primer cuartil, la mediana, la media, tercer cuartil y valor máximo.
Para las variables categóricas usamos Pie Charts.
boxplotBF <- function(df, clusterCol, attribute){
ggplot(data = df, mapping= aes(x = eval(parse(text=clusterCol)), y = eval(parse(text=attribute)), fill = eval(parse(text=clusterCol)))) +
geom_boxplot(outlier.colour="black", outlier.shape=16, outlier.size=2) +
stat_summary(fun.y=mean, geom="point", shape=23, size=4) +
labs(title = attribute, x=clusterCol , y = attribute)
}
pieChartBF <- function(df, clusterCol, attribute) {
ggplot(data=df, aes(x=factor(1), stat='identity', fill=eval(parse(text=attribute)))) +
theme(axis.text.x=element_blank(), axis.text.y=element_blank(), axis.ticks=element_blank()) +
facet_wrap(~eval(parse(text=clusterCol)))+
geom_bar(color="black",position = "fill") +
coord_polar(theta="y") +
labs(title = paste(attribute, " by cluster",sep="") , x="" , y = clusterCol, fill= attribute)
}clusterAnalysis <- function(df, clusterCol){
group<-compareGroups(as.formula(paste(clusterCol,"~.")),data=df, max.ylev=12, max.xlev = 21)
clustab<-createTable(group)
print(clustab)
PurchaseCluster <- boxplotBF(BlackFriday_Clustering, clusterCol, 'Purchase')
print(PurchaseCluster)
AgeCluster <- boxplotBF(BlackFriday_Clustering, clusterCol, 'Age_Int')
print(AgeCluster)
StayCityCluster <- boxplotBF(BlackFriday_Clustering, clusterCol, 'Stay_In_Current_City_Years')
print(StayCityCluster)
col_plot <- grep( "Product_Category", names(BlackFriday_Clustering),value=T)
dat.m <- melt(BlackFriday_Clustering, id.vars=clusterCol, measure.vars=col_plot)
ProdCatCluster <- ggplot(dat.m,aes(x=eval(parse(text=clusterCol)), y=value, color=variable)) +
geom_boxplot() +
labs(title="Product Categories by cluster", x=paste(clusterCol), y= "Item count") +
stat_summary(fun.y=mean, geom="point", shape=23, size=6)
print(ProdCatCluster)
print(pieChartBF(BlackFriday_Clustering, clusterCol,'City_Category'))
print(pieChartBF(BlackFriday_Clustering, clusterCol,'Gender'))
print(pieChartBF(BlackFriday_Clustering, clusterCol,'Occupation'))
print(pieChartBF(BlackFriday_Clustering, clusterCol,'Marital_Status'))
}Análisis de resultados
clusterAnalysis(BlackFriday_Clustering,"cluster_kmeans")##
## --------Summary descriptives table by 'cluster_kmeans'---------
##
## ________________________________________________________________________________________________________
## 1 2 3 4 p.overall
## N=1019 N=324 N=4285 N=263
## ¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
## Gender: <0.001
## F 272 (26.7%) 53 (16.4%) 1282 (29.9%) 59 (22.4%)
## M 747 (73.3%) 271 (83.6%) 3003 (70.1%) 204 (77.6%)
## Occupation: .
## 0 129 (12.7%) 34 (10.5%) 481 (11.2%) 44 (16.7%)
## 1 80 (7.85%) 20 (6.17%) 390 (9.10%) 27 (10.3%)
## 2 58 (5.69%) 9 (2.78%) 175 (4.08%) 14 (5.32%)
## 3 41 (4.02%) 9 (2.78%) 113 (2.64%) 7 (2.66%)
## 4 126 (12.4%) 41 (12.7%) 537 (12.5%) 36 (13.7%)
## 5 27 (2.65%) 7 (2.16%) 70 (1.63%) 7 (2.66%)
## 6 38 (3.73%) 15 (4.63%) 164 (3.83%) 11 (4.18%)
## 7 93 (9.13%) 28 (8.64%) 516 (12.0%) 32 (12.2%)
## 8 1 (0.10%) 1 (0.31%) 14 (0.33%) 1 (0.38%)
## 9 12 (1.18%) 2 (0.62%) 71 (1.66%) 3 (1.14%)
## 10 25 (2.45%) 10 (3.09%) 155 (3.62%) 2 (0.76%)
## 11 29 (2.85%) 7 (2.16%) 90 (2.10%) 2 (0.76%)
## 12 72 (7.07%) 28 (8.64%) 272 (6.35%) 4 (1.52%)
## 13 14 (1.37%) 2 (0.62%) 122 (2.85%) 2 (0.76%)
## 14 45 (4.42%) 17 (5.25%) 219 (5.11%) 13 (4.94%)
## 15 25 (2.45%) 14 (4.32%) 99 (2.31%) 2 (0.76%)
## 16 44 (4.32%) 15 (4.63%) 161 (3.76%) 15 (5.70%)
## 17 59 (5.79%) 43 (13.3%) 374 (8.73%) 15 (5.70%)
## 18 12 (1.18%) 1 (0.31%) 51 (1.19%) 3 (1.14%)
## 19 18 (1.77%) 6 (1.85%) 43 (1.00%) 4 (1.52%)
## 20 71 (6.97%) 15 (4.63%) 168 (3.92%) 19 (7.22%)
## City_Category: <0.001
## A 220 (21.6%) 67 (20.7%) 640 (14.9%) 118 (44.9%)
## B 514 (50.4%) 134 (41.4%) 914 (21.3%) 145 (55.1%)
## C 285 (28.0%) 123 (38.0%) 2731 (63.7%) 0 (0.00%)
## Stay_In_Current_City_Years 1.84 (1.28) 1.79 (1.25) 1.87 (1.28) 1.87 (1.35) 0.769
## Marital_Status: 0.492
## 0 611 (60.0%) 192 (59.3%) 2465 (57.5%) 149 (56.7%)
## 1 408 (40.0%) 132 (40.7%) 1820 (42.5%) 114 (43.3%)
## Age_Int 34.2 (10.7) 34.3 (10.5) 35.8 (12.2) 34.6 (10.1) <0.001
## Product_Category_1 43.7 (28.0) 47.2 (32.6) 12.1 (14.5) 101 (38.0) 0.000
## Product_Category_2 8.03 (5.78) 8.76 (5.63) 1.67 (2.34) 20.2 (9.25) 0.000
## Product_Category_3 7.05 (6.58) 5.71 (7.35) 1.64 (2.80) 14.5 (9.65) 0.000
## Product_Category_4 4.26 (4.41) 3.16 (3.55) 0.81 (1.43) 10.4 (7.28) 0.000
## Product_Category_5 52.1 (30.7) 32.8 (27.6) 12.3 (13.2) 122 (44.3) 0.000
## Product_Category_6 7.16 (4.74) 4.18 (4.01) 1.70 (2.38) 16.1 (7.72) 0.000
## Product_Category_7 1.40 (2.39) 0.69 (1.41) 0.27 (0.88) 3.32 (4.10) <0.001
## Product_Category_8 38.3 (24.0) 23.0 (20.3) 9.30 (10.0) 98.1 (44.0) 0.000
## Product_Category_9 0.00 (0.00) 1.00 (0.00) 0.00 (0.00) 0.30 (0.46) 0.000
## Product_Category_10 1.79 (1.96) 1.45 (1.53) 0.42 (0.91) 3.54 (2.52) 0.000
## Product_Category_11 7.10 (9.43) 8.02 (11.8) 1.74 (4.77) 25.3 (20.7) 0.000
## Product_Category_12 1.48 (2.09) 0.77 (1.65) 0.28 (0.85) 3.47 (3.36) 0.000
## Product_Category_13 2.05 (1.98) 1.45 (1.70) 0.36 (0.79) 5.15 (3.02) 0.000
## Product_Category_14 0.55 (0.95) 0.21 (0.54) 0.10 (0.36) 1.71 (1.73) 0.000
## Product_Category_15 1.83 (1.92) 3.17 (3.03) 0.43 (0.94) 5.54 (3.61) 0.000
## Product_Category_16 3.11 (3.03) 1.92 (2.63) 0.75 (1.15) 10.2 (6.62) 0.000
## Product_Category_17 0.19 (0.54) 0.18 (0.49) 0.04 (0.23) 0.59 (1.03) <0.001
## Product_Category_18 1.05 (1.80) 0.92 (1.79) 0.18 (0.68) 3.49 (3.36) 0.000
## Purchase 1661953 (581193) 1425576 (766195) 432200 (305060) 3841352 (1095676) 0.000
## ¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
K-Prototypes
La función kproto se puede aplicar directamente al dataframe inicial, ya que identifica las variables categóricas y numéricas.
Primero estudiamos el número óptimo de clusters
# No consideramos la columna de cluster añadida anteriormente por el kmeans
BlackFriday_kproto <- subset( BlackFriday_Clustering, select = -cluster_kmeans )
wss <- 0
for (i in 1:15) {
km.out <- kproto(BlackFriday_kproto, i, nstar=1)
wss[i] <- km.out$tot.withinss
}plot(1:15, wss, type = "b", xlab = "Number of Clusters",
ylab = "Within groups sum of squares")
Seleccionamos 4 clusters
reskproto <- kproto(BlackFriday_kproto, 4, nstar=5)
BlackFriday_Clustering$cluster_kproto <- as.factor(reskproto$cluster)Análisis de resultados
Hay algunas variables sobre las que no se aprecian diferencias significativos entre los clusters al tener medias y distribuciones parecidas: - Age: Media 35 años - Stay_In_Current_City_Years: Media 1.8 años - Gender: 75% Hombre - Marital Status: Al 50% - Occupation: Dominan levemente las clases 0, 4, 7
Aún así, se pueden observar algunas características interesantes de cada cluster:
- Cluster 1: Gasto medio 2500, Mayoría ciudad B, Media de 50 productos categorías 1,5,8
- Cluster 2: Gasto medio 1000, Mitad ciudad C, Media de 30 productos categorías 1, 5
- Cluster 3 (Más grande 3500 clientes): Gasto medio menor (310), Mayoría ciudad C, Pocos productos (5/10 categoría 1, 5).
- Cluster 4 (Más pequeño 199 clientes): Mayor gasto 4200, Solo ciudad A y B, Media mayor a 100 productos categorías 1, 5, 8; Media mayor a 20 productos categorías 2, 20.
clusterAnalysis(BlackFriday_Clustering,'cluster_kproto')##
## --------Summary descriptives table by 'cluster_kproto'---------
##
## ________________________________________________________________________________________________________
## 1 2 3 4 p.overall
## N=3497 N=677 N=1518 N=199
## ¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
## Gender: <0.001
## F 1126 (32.2%) 141 (20.8%) 360 (23.7%) 39 (19.6%)
## M 2371 (67.8%) 536 (79.2%) 1158 (76.3%) 160 (80.4%)
## Occupation: .
## 0 401 (11.5%) 87 (12.9%) 167 (11.0%) 33 (16.6%)
## 1 310 (8.86%) 44 (6.50%) 143 (9.42%) 20 (10.1%)
## 2 141 (4.03%) 42 (6.20%) 65 (4.28%) 8 (4.02%)
## 3 97 (2.77%) 25 (3.69%) 42 (2.77%) 6 (3.02%)
## 4 405 (11.6%) 95 (14.0%) 216 (14.2%) 24 (12.1%)
## 5 61 (1.74%) 20 (2.95%) 25 (1.65%) 5 (2.51%)
## 6 149 (4.26%) 24 (3.55%) 44 (2.90%) 11 (5.53%)
## 7 437 (12.5%) 79 (11.7%) 127 (8.37%) 26 (13.1%)
## 8 12 (0.34%) 1 (0.15%) 3 (0.20%) 1 (0.50%)
## 9 68 (1.94%) 4 (0.59%) 13 (0.86%) 3 (1.51%)
## 10 137 (3.92%) 7 (1.03%) 46 (3.03%) 2 (1.01%)
## 11 76 (2.17%) 19 (2.81%) 31 (2.04%) 2 (1.01%)
## 12 213 (6.09%) 33 (4.87%) 125 (8.23%) 5 (2.51%)
## 13 104 (2.97%) 2 (0.30%) 33 (2.17%) 1 (0.50%)
## 14 177 (5.06%) 36 (5.32%) 70 (4.61%) 11 (5.53%)
## 15 80 (2.29%) 18 (2.66%) 40 (2.64%) 2 (1.01%)
## 16 123 (3.52%) 39 (5.76%) 64 (4.22%) 9 (4.52%)
## 17 296 (8.46%) 48 (7.09%) 138 (9.09%) 9 (4.52%)
## 18 37 (1.06%) 6 (0.89%) 21 (1.38%) 3 (1.51%)
## 19 37 (1.06%) 12 (1.77%) 19 (1.25%) 3 (1.51%)
## 20 136 (3.89%) 36 (5.32%) 86 (5.67%) 15 (7.54%)
## City_Category: <0.001
## A 499 (14.3%) 176 (26.0%) 276 (18.2%) 94 (47.2%)
## B 723 (20.7%) 428 (63.2%) 451 (29.7%) 105 (52.8%)
## C 2275 (65.1%) 73 (10.8%) 791 (52.1%) 0 (0.00%)
## Stay_In_Current_City_Years 1.85 (1.27) 1.84 (1.23) 1.87 (1.31) 1.91 (1.36) 0.864
## Marital_Status: 0.062
## 0 1989 (56.9%) 418 (61.7%) 900 (59.3%) 110 (55.3%)
## 1 1508 (43.1%) 259 (38.3%) 618 (40.7%) 89 (44.7%)
## Age_Int 36.0 (12.4) 33.2 (9.69) 34.9 (11.4) 34.2 (9.97) <0.001
## Product_Category_1 7.60 (6.92) 64.7 (29.4) 30.1 (18.2) 112 (35.2) 0.000
## Product_Category_2 1.28 (1.87) 10.9 (6.49) 4.78 (4.12) 22.1 (9.14) 0.000
## Product_Category_3 1.39 (2.65) 8.38 (7.13) 4.13 (5.25) 15.3 (10.00) 0.000
## Product_Category_4 0.71 (1.53) 5.19 (4.81) 2.24 (3.02) 10.9 (7.35) 0.000
## Product_Category_5 9.25 (9.07) 66.8 (32.9) 29.7 (21.6) 130 (43.8) 0.000
## Product_Category_6 1.28 (1.81) 8.75 (5.07) 4.18 (3.73) 17.2 (8.14) 0.000
## Product_Category_7 0.21 (0.77) 1.70 (2.82) 0.73 (1.58) 3.32 (3.98) <0.001
## Product_Category_8 7.14 (6.87) 48.9 (28.2) 22.2 (16.9) 102 (48.4) 0.000
## Product_Category_9 0.02 (0.13) 0.20 (0.40) 0.09 (0.29) 0.33 (0.47) <0.001
## Product_Category_10 0.37 (0.88) 1.97 (1.96) 1.13 (1.57) 3.53 (2.65) 0.000
## Product_Category_11 1.42 (4.13) 10.8 (13.1) 4.21 (7.59) 26.4 (20.7) 0.000
## Product_Category_12 0.27 (0.92) 1.68 (2.28) 0.74 (1.47) 3.35 (3.42) <0.001
## Product_Category_13 0.29 (0.76) 2.52 (2.20) 1.11 (1.52) 5.11 (3.18) 0.000
## Product_Category_14 0.08 (0.33) 0.65 (1.08) 0.29 (0.68) 1.66 (1.81) <0.001
## Product_Category_15 0.36 (0.85) 2.73 (2.55) 1.29 (1.85) 5.68 (3.83) 0.000
## Product_Category_16 0.62 (0.99) 4.26 (3.73) 1.65 (2.07) 10.7 (7.05) 0.000
## Product_Category_17 0.03 (0.21) 0.27 (0.69) 0.10 (0.39) 0.55 (0.93) <0.001
## Product_Category_18 0.15 (0.66) 1.50 (2.24) 0.57 (1.35) 3.36 (3.15) <0.001
## Purchase 310419 (165500) 2213471 (428923) 1049981 (267304) 4219815 (1008682) 0.000
## cluster_kmeans: 0.000
## 1 16 (0.46%) 470 (69.4%) 522 (34.4%) 11 (5.53%)
## 2 64 (1.83%) 117 (17.3%) 138 (9.09%) 5 (2.51%)
## 3 3417 (97.7%) 10 (1.48%) 858 (56.5%) 0 (0.00%)
## 4 0 (0.00%) 80 (11.8%) 0 (0.00%) 183 (92.0%)
## ¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
K-medoids distancia Gower
(https://www.rdocumentation.org/packages/StatMatch/versions/1.2.0/topics/gower.dist) (https://towardsdatascience.com/clustering-on-mixed-type-data-8bbd0a2569c3) La distancia Gower permite trabajar con datos tanto categóricos como continuos.
Crea una matriz de disimilitud basada en la media de distancias parciales (cada atributo) entre individuos. Según el tipo de variable, la distancia parcial se calcula con una fórmula distinta.
Para variables categóricas la distancia es 0 si el valor es igual y 1 si son distintas. Para variables numéricas se usa la diferencia en valor absoluto dividida por el mayor rango de la variable.
La distancia Gower funciona bien con el algoritmo PAM (Partitioning around mediods). PAM es parecido a K-means, pero los centros de cada cluster en vez de ser centroides de medias definidas por distancia Euclidea, son directamente ciertos individuos (medoids). Esto es útil para la interpretación ya que el centro representa un “individuo típico” de cada cluster. Sin embargo, este método requiere más tiempo y cálculo (orden cuadrático)
BlackFriday_pam <- subset( BlackFriday_Clustering, select = -c(cluster_kmeans,cluster_kproto) )
head(BlackFriday_pam)Calculamos la matriz de distancias gower con la función daisy
gower_dist <- daisy(BlackFriday_pam, metric = "gower")## Warning in daisy(BlackFriday_pam, metric = "gower"): binary variable(s) 15
## treated as interval scaledgower_mat <- as.matrix(gower_dist)Para comprobar que la distancia gower se calcula correctamente, la matriz nos permite obtener, por ejemplo, los clientes más y menos similares
# Clientes más parecidos
BlackFriday_pam[which(gower_mat == min(gower_mat[gower_mat != min(gower_mat)]), arr.ind = TRUE)[1, ], ]# Clientes menos parecidos
BlackFriday_pam[which(gower_mat == max(gower_mat[gower_mat != max(gower_mat)]), arr.ind = TRUE)[1, ], ]Para calcular el número óptimo de clusters en este caso, usamos el que tenga mayor silhouette width, que mide la similitud de un objeto con su cluster comparado con los demás
sil_width <- c(NA)
for(i in 2:8){
pam_fit <- pam(gower_dist, diss = TRUE, k = i)
sil_width[i] <- pam_fit$silinfo$avg.width
}
plot(1:8, sil_width,
xlab = "Number of clusters",
ylab = "Silhouette Width")
lines(1:8, sil_width)
El mayor valor de silhouette width se da con 2 clusters, pero elegimos 3 ya que tiene un valor parecido y nos puede aportar más información.
Visualizamos la representación en 2D
pam_fit <- pam(gower_dist, diss = TRUE, k = 3)
tsne_obj <- Rtsne(gower_dist, is_distance = TRUE)
tsne_data <- tsne_obj$Y %>%
data.frame() %>%
setNames(c("X", "Y")) %>%
mutate(cluster = factor(pam_fit$clustering))
ggplot(aes(x = X, y = Y), data = tsne_data) +
geom_point(aes(color = cluster))
Creamos columna de cluster_pam
BlackFriday_Clustering$cluster_pam <- as.factor(pam_fit$clustering)Análisis de resultados
Con este resultado se obtienen diferencias en los clusters en un mayor número de variables, y los clusters son de un tamaño similar.
Hay algunas variables sobre las que no se aprecian diferencias significativos entre los clusters al tener medias y distribuciones parecidas: - Stay_In_Current_City_Years: Media 1.8 años - Gender: 70% Hombre - Product_Category: Todos compran mayormente productos tipo 1, 5, 8. Solo el cluster 3 destaca por tener un volumen de compra mayor de estos productos
Se pueden observar algunas características interesantes de cada cluster:
- Cluster 1: Gasto medio 535, Mayoría ciudad C, Edad media 32, Ocupación mayoritaria 0, Estado civil 0
- Cluster 2: Gasto medio 602, Mayoría ciudad C, Edad media 41, Ocupación mayoritaria 7, Estado civil 1
- Cluster 3: Gasto medio mayor (1580), Mayoría ciudad B, Edad media 31, Ocupación mayoritaria 4, Estado civil 0
clusterAnalysis(BlackFriday_Clustering,'cluster_pam')##
## --------Summary descriptives table by 'cluster_pam'---------
##
## ______________________________________________________________________________________
## 1 2 3 p.overall
## N=2200 N=2040 N=1651
## ¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
## Gender: 0.113
## F 644 (29.3%) 587 (28.8%) 435 (26.3%)
## M 1556 (70.7%) 1453 (71.2%) 1216 (73.7%)
## Occupation: .
## 0 493 (22.4%) 95 (4.66%) 100 (6.06%)
## 1 186 (8.45%) 205 (10.0%) 126 (7.63%)
## 2 80 (3.64%) 92 (4.51%) 84 (5.09%)
## 3 49 (2.23%) 69 (3.38%) 52 (3.15%)
## 4 207 (9.41%) 102 (5.00%) 431 (26.1%)
## 5 35 (1.59%) 36 (1.76%) 40 (2.42%)
## 6 61 (2.77%) 109 (5.34%) 58 (3.51%)
## 7 136 (6.18%) 425 (20.8%) 108 (6.54%)
## 8 10 (0.45%) 5 (0.25%) 2 (0.12%)
## 9 28 (1.27%) 41 (2.01%) 19 (1.15%)
## 10 141 (6.41%) 7 (0.34%) 44 (2.67%)
## 11 42 (1.91%) 45 (2.21%) 41 (2.48%)
## 12 149 (6.77%) 128 (6.27%) 99 (6.00%)
## 13 37 (1.68%) 88 (4.31%) 15 (0.91%)
## 14 94 (4.27%) 125 (6.13%) 75 (4.54%)
## 15 43 (1.95%) 55 (2.70%) 42 (2.54%)
## 16 68 (3.09%) 108 (5.29%) 59 (3.57%)
## 17 204 (9.27%) 172 (8.43%) 115 (6.97%)
## 18 27 (1.23%) 28 (1.37%) 12 (0.73%)
## 19 37 (1.68%) 12 (0.59%) 22 (1.33%)
## 20 73 (3.32%) 93 (4.56%) 107 (6.48%)
## City_Category: 0.000
## A 358 (16.3%) 322 (15.8%) 365 (22.1%)
## B 137 (6.23%) 335 (16.4%) 1235 (74.8%)
## C 1705 (77.5%) 1383 (67.8%) 51 (3.09%)
## Stay_In_Current_City_Years 1.71 (1.30) 1.94 (1.26) 1.96 (1.27) <0.001
## Marital_Status: 0.000
## 0 2047 (93.0%) 112 (5.49%) 1258 (76.2%)
## 1 153 (6.95%) 1928 (94.5%) 393 (23.8%)
## Age_Int 32.7 (11.4) 41.3 (11.5) 31.6 (9.77) <0.001
## Product_Category_1 15.2 (19.3) 16.1 (22.1) 43.7 (38.1) <0.001
## Product_Category_2 2.34 (3.63) 2.65 (4.29) 7.85 (8.01) <0.001
## Product_Category_3 2.30 (4.28) 2.06 (3.86) 6.41 (7.31) <0.001
## Product_Category_4 1.24 (2.54) 1.21 (2.43) 3.87 (5.06) <0.001
## Product_Category_5 15.3 (19.6) 16.9 (23.4) 48.7 (43.8) <0.001
## Product_Category_6 2.09 (3.24) 2.39 (3.69) 6.49 (6.27) <0.001
## Product_Category_7 0.35 (1.26) 0.43 (1.31) 1.22 (2.39) <0.001
## Product_Category_8 11.0 (14.8) 14.0 (20.6) 35.9 (35.6) <0.001
## Product_Category_9 0.04 (0.19) 0.05 (0.21) 0.14 (0.34) <0.001
## Product_Category_10 0.49 (1.04) 0.71 (1.40) 1.51 (1.95) <0.001
## Product_Category_11 2.42 (5.87) 2.46 (6.54) 8.24 (13.5) <0.001
## Product_Category_12 0.33 (0.98) 0.55 (1.46) 1.22 (2.13) <0.001
## Product_Category_13 0.52 (1.16) 0.69 (1.48) 1.74 (2.27) <0.001
## Product_Category_14 0.14 (0.48) 0.18 (0.60) 0.49 (1.03) <0.001
## Product_Category_15 0.62 (1.29) 0.74 (1.61) 2.01 (2.68) <0.001
## Product_Category_16 0.95 (1.76) 1.18 (2.30) 3.14 (4.34) <0.001
## Product_Category_17 0.04 (0.25) 0.09 (0.37) 0.18 (0.56) <0.001
## Product_Category_18 0.25 (0.82) 0.42 (1.38) 1.01 (1.98) <0.001
## Purchase 535615 (525969) 602529 (653107) 1580956 (1212211) 0.000
## cluster_kmeans: <0.001
## 1 182 (8.27%) 213 (10.4%) 624 (37.8%)
## 2 80 (3.64%) 82 (4.02%) 162 (9.81%)
## 3 1922 (87.4%) 1713 (84.0%) 650 (39.4%)
## 4 16 (0.73%) 32 (1.57%) 215 (13.0%)
## cluster_kproto: 0.000
## 1 1615 (73.4%) 1460 (71.6%) 422 (25.6%)
## 2 50 (2.27%) 103 (5.05%) 524 (31.7%)
## 3 521 (23.7%) 453 (22.2%) 544 (32.9%)
## 4 14 (0.64%) 24 (1.18%) 161 (9.75%)
## ¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
Conclusiones
Usando el algoritmo K-medoids obtenemos un mejor resultado. La partición en clusters es más significativa puesto que se aprecian mayores diferencias entre las características de cada cluster. El peor resultado fue al usar el K-means ya que su aplicación a variables mixtas (categóricas y numéricas) no es directa y la codificación incrementa el número de atributos y su complejidad. Sin embargo, con vistas a categorizar clientes según sus compras (tipo de producto) no se pueden obtener muchas conclusiones ya que existe una gran tendencia de todos los clientes a comprar productos de las categorías 1, 5, y 8. Por lo tanto es díficil discernir grupos que prefieran unas categorías sobre otras. En cuanto al gasto total si se pueden apreciar diferencias, pero no en cuanto a qué compran los clientes. Esto ocurre con otros atributos como la edad, el genéro, o el número de años en la ciudad, ya que tienen un valor muy frecuente en el conjunto de datos que siempre dominan los clusters.